Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/gls/mrequire.scm

Text File | 1995-01-07 | 5.3 KB | 153 lines

;;; $Id: mrequire.scm,v 1.1 1995/01/06 17:59:57 miles Exp $
;;; ----------------------------------------------------------------
;;; mrequire.scm -- Wrapper for slib require/provide that makes it modular
;;; 4 Jan 1995, Miles Bader <[e-mail]>
;;; ----------------------------------------------------------------
;;;

(in-package slib)

(export-library slib (slib require) guile (record defmacro))
(export-library guile (slib))        ; make slib usable from the guile lib

(use-library guile)

;; ----------------------------------------------------------------

(in-module slib)

(export-interface require
 (REQUIRE PROVIDE PROVIDED?
  (REQUIRE REQUIRE:REQUIRE)
  (PROVIDE REQUIRE:PROVIDE)
  (PROVIDED? REQUIRE:PROVIDED?)))

;; The initial interface used by an slib module
(export-interface slib
 require
 slib-hooks
 vicinity
 time
 guile)

(use-interface guile)
(use-interface guile-internals)
(use-interface slib-hooks (*features*))
(use-interface module)
(use-interface variable)
(use-interface vicinity)

;; ----------------------------------------------------------------

(define *require-pathname* (in-vicinity (library-vicinity) "require.scm"))

(define *slib-package* (find-module 'slib *root-package* #f))
(define *slib-library* (find-interface 'slib *root-package* #f))

(define *slib-module-initial-interface*
  (find-interface 'slib *slib-package* #f))

(define (make-slib-module)
  (let ((module (make-module)))
    (module-use! module *slib-module-initial-interface*)
    module))

;; ----------------------------------------------------------------

(define *require-module*
  (find-module 'require *slib-package* make-slib-module))

;; The internal variables in the require module that we fuck with to fool the
;; slib require/provide code into using modules.  We just share variables in
;; our module with it.
;;
(define *provide-variable* (module-variable (current-module) 'provide))
(module-add! *require-module* 'provide *provide-variable*)
(module-add! *require-module* 'require:provide *provide-variable*)
;;
(define *require-variable* (module-variable (current-module) 'require))
(module-add! *require-module* 'require *require-variable*)
(module-add! *require-module* 'require:require *require-variable*)
;;
(define *provided?-variable* (module-variable (current-module) 'provided?))
(module-add! *require-module* 'provided? *provided?-variable*)
(module-add! *require-module* 'require:provided? *provided?-variable*)

;; Load the slib require code into our deviously prepared receptacle...
(let ((load-module *load-module*))
  (dynamic-wind (lambda () (set! *load-module* *require-module*))
        (lambda () (try-load *require-pathname*))
        (lambda () (set! *load-module* load-module))))

;; Stash the slib version of these routines
(define slib-require (variable-ref *require-variable*))
(define slib-provide (variable-ref *provide-variable*))
(define slib-provided? (variable-ref *provided?-variable*))

;; Things not represented by separate interfaces (that are in the core)
(define *core-features*
  (do ((features *features* (cdr features))
       (core '()))
      ((null? features) core)
    (if (not (module-bound? *slib-library* (car features)))
    (set! core (cons (car features) core)))))

;; ----------------------------------------------------------------

;; Require loads the given slib code into its own unique module in the slib
;; package,
(define (require name)
  (if (not (memq name *core-features*))
      (let ((interface (module-ref *slib-library* name #f)))
    (if (not interface)
        (let* (;; the new module to put the loaded code into
           (module (find-module name *slib-package* make-slib-module))
           ;; what to restore *load-module* to after loading
           (old-load-module *load-module*)
           ;; what to restore the current-module to after loading
           (old-module (current-module))
           ;; A list of things PROVIDEd by the module
           (names (list name))
           ;; A provide routine that stashes the names in NAMES
           (%provide
            (lambda (what)
              (if (symbol? what)
              (set! names (cons what (delq! what names))))
              (slib-provide what)))
           ;; what to restore the provide routine to
           (old-provide (variable-ref *provide-variable*)))
          (dynamic-wind
           (lambda ()
         (variable-set! *provide-variable* %provide)
         (set! *load-module* module)
         (set-current-module module))
           (lambda ()
         (slib-require name))
           (lambda ()
         (set-current-module old-module)
         (set! *load-module* old-load-module)
         (variable-set! *provide-variable* old-provide)))

          ;; Make an interface to this module; although it has exactly
          ;; the same contents as MODULE, we need a separate interface to
          ;; avoid use-loops.
          (set! interface (find-interface name *slib-package* #t))

          ;; Export everything in the module to the interface
          (module-export module interface)

          ;; Alias the same interface under any other PROVIDEd names
          (for-each (lambda (alias)
              (if (not (eq? alias name))
                  (import-variable name *slib-package*
                           alias *slib-package*)))
            (cdr names))

          ;; And export all of them from the slib library
          (module-export *slib-package* *slib-library* names)))
    (module-use! (current-module) interface))))

(define (provided? feature)
  (or (and (symbol? feature) (module-bound? *slib-library* feature))
      (slib-provided? feature)))